home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Cream of the Crop 20
/
Cream of the Crop 20 (Terry Blount) (1996).iso
/
os2
/
lxlt115.zip
/
SOURCES
/
EXE386.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1996-06-19
|
70KB
|
1,888 lines
(****************************************************************************)
(* Title: exe386.pas *)
(* Description: Data structure definitions for the OS/2 executable file *)
(* format (flat model); additionaly contains a handy object *)
(* for LX files manipulations (tLX). *)
(****************************************************************************)
(* Copyright (c) IBM Corporation 1987, 1992 *)
(* Copyright (c) Microsoft Corp 1988, 1991 *)
(* C->Pascal conversion (c) FRIENDS software, 1996 *)
(* tLX object implementation (c) FRIENDS software, 1996 *)
(****************************************************************************)
{$AlignCode-,AlignData-,AlignRec-,G3+,Speed-,Frame-}
Unit exe386;
Interface uses use32, miscUtil;
const
lxfMagic = $584C; { New magic number "LX" }
exeMagic1 = $5A4D; { EXE file magic number "MZ" }
exeMagic2 = $4D5A; { EXE file magic number "ZM" }
lxResBytes = 24; { bytes reserved }
lxLEBO = $00; { Little Endian Byte Order }
lxBEBO = $01; { Big Endian Byte Order }
lxLEWO = $00; { Little Endian Word Order }
lxBEWO = $01; { Big Endian Word Order }
lxLevel = 0; { 32-bit EXE format level }
lxCPU286 = $01; { Intel 80286 or upwardly compatibile }
lxCPU386 = $02; { Intel 80386 or upwardly compatibile }
lxCPU486 = $03; { Intel 80486 or upwardly compatibile }
lxCPUP5 = $04; { Intel P5 or upwardly compatibile }
type pLXheader = ^tLXheader;
tLXheader = record { New 32-bit .EXE header }
lxMagic : SmallWord; { magic number LXmagic }
lxBOrder : Byte; { The byte ordering for the .EXE }
lxWOrder : Byte; { The word ordering for the .EXE }
lxLevel : Longint; { The EXE format level for now = 0 }
lxCpu : SmallWord; { The CPU type }
lxOS : SmallWord; { The OS type }
lxVer : Longint; { Module version }
lxMflags : Longint; { Module flags }
lxMpages : Longint; { Module # pages }
lxStartObj : Longint; { Object # for instruction pointer }
lxEIP : Longint; { Extended instruction pointer }
lxStackObj : Longint; { Object # for stack pointer }
lxESP : Longint; { Extended stack pointer }
lxPageSize : Longint; { .EXE page size }
lxPageShift : Longint; { Page alignment shift in .EXE }
lxFixupSize : Longint; { Fixup section size }
lxFixupSum : Longint; { Fixup section checksum }
lxLdrSize : Longint; { Loader section size }
lxLdrSum : Longint; { Loader section checksum }
lxObjTabOfs : Longint; { Object table offset }
lxObjCnt : Longint; { Number of objects in module }
lxObjMapOfs : Longint; { Object page map offset }
lxIterMapOfs : Longint; { Object iterated data map offset }
lxRsrcTabOfs : Longint; { Offset of Resource Table }
lxRsrcCnt : Longint; { Number of resource entries }
lxResTabOfs : Longint; { Offset of resident name table }
lxEntTabOfs : Longint; { Offset of Entry Table }
lxDirTabOfs : Longint; { Offset of Module Directive Table }
lxDirCnt : Longint; { Number of module directives }
lxFPageTabOfs: Longint; { Offset of Fixup Page Table }
lxFRecTabOfs : Longint; { Offset of Fixup Record Table }
lxImpModOfs : Longint; { Offset of Import Module Name Table }
lxImpModCnt : Longint; { Number of entries in Import Module Name Table }
lxImpProcOfs : Longint; { Offset of Import Procedure Name Table }
lxPageSumOfs : Longint; { Offset of Per-Page Checksum Table }
lxDataPageOfs: Longint; { Offset of Enumerated Data Pages }
lxPreload : Longint; { Number of preload pages }
lxNResTabOfs : Longint; { Offset of Non-resident Names Table }
lxCbNResTabOfs:Longint; { Size of Non-resident Name Table }
lxNResSum : Longint; { Non-resident Name Table Checksum }
lxAutoData : Longint; { Object # for automatic data object }
lxDebugInfoOfs:Longint; { Offset of the debugging information }
{ RELATIVE TO START OF EXE FILE}
lxDebugLen : Longint; { The length of the debugging info. in bytes }
lxInstPreload: Longint; { Number of instance pages in preload section of .EXE file }
lxInstDemand : Longint; { Number of instance pages in demand load section of .EXE file }
lxHeapSize : Longint; { Size of heap - for 16-bit apps }
lxReserved : array[1..lxResBytes] of Byte;
end; { Pad structure to 196 bytes }
{ Format of lxMFlags: }
{ }
{ Low word has the following format: }
{ }
{ 15 14 13 12 11 10 9 8 7 6 5 4 3 2 1 0 - bit no }
{ | | | | | | | }
{ | | | | | | +------- Per-Process Library Initialization}
{ | | | | | +----------- No Internal Fixups for Module in .EXE}
{ | | | | +------------- No External Fixups for Module in .EXE}
{ | | | +------------------- Incompatible with PM Windowing }
{ | | +--------------------- Compatible with PM Windowing }
{ | | Uses PM Windowing API }
{ | +-------------------------------- Module not Loadable }
{ +-------------------------------------- Library Module }
const
lxNoLoad = $00002000; { Module not Loadable }
lxNoTP = $00008000; { Library Module - used as NEnoTP }
lxNoPMwin = $00000100; { Incompatible with PM Windowing }
lxPMwin = $00000200; { Compatible with PM Windowing }
lxPMapi = $00000300; { Uses PM Windowing API }
lxNoIntFix = $00000010; { NO Internal Fixups in .EXE }
lxNoExtFix = $00000020; { NO External Fixups in .EXE }
lxLibInit = $00000004; { Per-Process Library Initialization }
lxLibTerm = $40000000; { Per-Process Library Termination }
lxAppMask = $00000700; { Application Type Mask }
{ Format of lxMFlags }
{ }
{ High word has the following format: }
{ 15 14 13 12 11 10 9 8 7 6 5 4 3 2 1 0 - bit no }
{ | | }
{ | +--- Protected memory library module }
{ +----- Device driver }
const
lxEXE = $00000000; { .EXE module }
lxDLL = $00008000; { Dynamic Link library }
lxPMDLL = $00018000; { Protected memory library module }
lxPDD = $00020000; { Physical device driver }
lxVDD = $00028000; { Virtual device driver }
lxModType = $00038000; { Module type mask }
{ RELOCATION DEFINITIONS - RUN-TIME FIXUPS }
type pOffset = ^tOffset;
tOffset = record case byte of
0 : (offset16 : SmallWord);
1 : (offset32 : Longint);
end; { 16-bit or 32-bit offset }
{ ET + lxrrlc - Relocation item }
pRelocation = ^tRelocation;
tRelocation = record { Relocation item }
nr_SType : Byte; { Source type - field shared with new_rlc }
nr_Flags : Byte; { Flag byte - field shared with new_rlc }
rSoff : SmallWord; { Source offset }
rObjMod : SmallWord; { Target object number or Module ordinal }
rTarget : record case Byte of
0 : (intRef : tOffset);
1 : (extRef : record case byte of
0 : (Proc : tOffset); { Procedure name offset }
1 : (Ord : Longint); { Procedure ordinal }
end);
2 : (addFix : record case byte of
0 : (entry : SmallWord);
1 : (AddVal : tOffset);
end);
end;
rSrcCount : SmallWord; { Number of chained fixup records }
rChain : SmallWord; { Chain head }
end;
{ In 32-bit .EXE file run-time relocations are written as varying size }
{ records, so we need many size definitions. }
const
rIntSize16 = 8;
rIntSize32 = 10;
rOrdSize = 8;
rNamSize16 = 8;
rNamSize32 = 10;
rAddSize16 = 10;
rAddSize32 = 12;
{ Format of NR_STYPE(x) }
{ 7 6 5 4 3 2 1 0 - bit no }
{ | | | | | | }
{ | | +-+-+-+--- Source type }
{ | +----------- Fixup to 16:16 alias }
{ +------------- List of source offset follows fixup record }
const
nrSType = $0F; { Source type mask }
nrSByte = $00; { lo byte (8-bits)}
nrSSeg = $02; { 16-bit segment (16-bits) }
nrSPtr = $03; { 16:16 pointer (32-bits) }
nrSOff = $05; { 16-bit offset (16-bits) }
nrPtr48 = $06; { 16:32 pointer (48-bits) }
nrOff32 = $07; { 32-bit offset (32-bits) }
nrSoff32 = $08; { 32-bit self-relative offset (32-bits) }
nrSrcMask = $0F; { Source type mask }
nrAlias = $10; { Fixup to alias }
nrChain = $20; { List of source offset follows }
{ fixup record, source offset field }
{ in fixup record contains number }
{ of elements in list }
{ Format of NR_FLAGS(x) and lxrFLAGS(x): }
{ 7 6 5 4 3 2 1 0 - bit no }
{ | | | | | | | }
{ | | | | | +-+--- Reference type }
{ | | | | +------- Additive fixup }
{ | | | +----------- 32-bit Target Offset Flag (1 - 32-bit; 0 - 16-bit) }
{ | | +------------- 32-bit Additive Flag (1 - 32-bit; 0 - 16-bit) }
{ | +--------------- 16-bit Object/Module ordinal (1 - 16-bit; 0 - 8-bit) }
{ +----------------- 8-bit import ordinal (1 - 8-bit; }
{ 0 - NR32BITOFF toggles }
{ between 16 and 32 bit }
{ ordinal) }
const
nrRtype = $03; { Reference type mask }
nrRint = $00; { Internal reference }
nrRord = $01; { Import by ordinal }
nrRnam = $02; { Import by name }
nrAdd = $04; { Additive fixup }
nrRent = $03; { Internal entry table fixup }
nr32bitOff = $10; { 32-bit Target Offset }
nr32bitAdd = $20; { 32-bit Additive fixup }
nr16objMod = $40; { 16-bit Object/Module ordinal }
nr8bitOrd = $80; { 8-bit import ordinal }
{ OBJECT TABLE }
{ Object Table Entry }
type
pObjTblRec = ^tObjTblRec;
tObjTblRec = record { Flat .EXE object table entry }
oSize : Longint; { Object virtual size }
oBase : Longint; { Object base virtual address }
oFlags : Longint; { Attribute flags }
oPageMap : Longint; { Object page map index }
oMapSize : Longint; { Number of entries in object page map }
oReserved : Longint; { Reserved }
end;
{ Format of oFlags }
{ }
{ High word of dword flag field is not used for now. }
{ Low word has the following format: }
{ 15 14 13 12 11 10 9 8 7 6 5 4 3 2 1 0 - bit no }
{ | | | | | | | | | | | | | | | }
{ | | | | | | | | | | | | | | +--- Readable Object }
{ | | | | | | | | | | | | | +----- Writeable Object }
{ | | | | | | | | | | | | +------- Executable Object }
{ | | | | | | | | | | | +--------- Resource Object }
{ | | | | | | | | | | +----------- Object is Discardable }
{ | | | | | | | | | +------------- Object is Shared }
{ | | | | | | | | +--------------- Object has preload pages }
{ | | | | | | | +----------------- Object has invalid pages }
{ | | | | | | +------------------- Object is permanent and swappable }
{ | | | | | +--------------------- Object is permanent and resident }
{ | | | | +----------------------- Object is permanent and long lockable}
{ | | | +----------------------------- 16:16 alias required (80x86 specific)}
{ | | +-------------------------------- Big/Default bit setting (80x86 specific)}
{ | +----------------------------------- Object is conforming for code (80x86 specific)}
{ +-------------------------------------- Object I/O privilege level (80x86 specific)}
const
objRead = $00000001; { Readable object }
objWrite = $00000002; { Writeable object }
objExec = $00000004; { Executable object }
objResource = $00000008; { Resource object }
objDiscard = $00000010; { object is Discardable }
objShared = $00000020; { object is Shared }
objPreload = $00000040; { object has preload pages }
objInvalid = $00000080; { object has invalid pages }
lnkNonPerm = $00000600; { object is nonpermanent - should be }
objNonPerm = $00000000; { zero in the .EXE but LINK386 uses 6 }
objPerm = $00000100; { object is permanent and swappable }
objResident = $00000200; { object is permanent and resident }
objContig = $00000300; { object is resident and contiguous }
objDynamic = $00000400; { object is permanent and long locable }
objTypeMask = $00000700; { object type mask }
objAlias16 = $00001000; { 16:16 alias required (80x86 specific) }
objBigDef = $00002000; { Big/Default bit setting (80x86 specific) }
objConform = $00004000; { object is conforming for code (80x86 specific) }
objIOPL = $00008000; { object I/O privilege level (80x86 specific) }
{ object Page Map entry }
type pObjMapRec = ^tObjMapRec;
tObjMapRec = record { object Page Table entry }
PageDataOffset : Longint; { file offset of page }
PageSize : SmallWord; { # bytes of page data }
PageFlags : SmallWord; { Per-Page attributes }
end;
const
pgValid = $0000; { Valid Physical Page in .EXE }
pgIterData = $0001; { Iterated Data Page }
pgInvalid = $0002; { Invalid Page }
pgZeroed = $0003; { Zero Filled Page }
pgRange = $0004; { Range of pages }
pgIterData2 = $0005; { Iterated Data Page Type II }
{ RESOURCE TABLE }
{ tResource - Resource Table Entry }
type pResource = ^tResource;
tResource = record { Resource Table Entry }
resType : SmallWord; { Resource type }
resName : SmallWord; { Resource name }
resSize : Longint; { Resource size }
resObj : SmallWord; { Object number }
resOffs : Longint; { Offset within object }
end;
{ Iteration Record format for 'EXEPACK'ed pages. (DCR1346) }
pIterRec = ^tIterRec;
tIterRec = record
nIter : SmallWord; { number of iterations }
nBytes : SmallWord; { number of bytes }
IterData : Byte; { iterated data byte(s) }
end;
{ ENTRY TABLE DEFINITIONS }
{ Entry Table bundle }
pEntryTblRec = ^tEntryTblRec;
tEntryTblRec = record
Count : Byte; { Number of entries in this bundle }
BndType : Byte; { Bundle type }
Obj : SmallWord; { object number }
end; { Follows entry types }
pEntry = ^tEntry;
tEntry = record
Flags : Byte; { Entry point flags }
Variant : record case byte of { Entry variant }
0 : (Offset : tOffset); { 16-bit/32-bit offset entry }
1 : (CallGate : record
Offset : SmallWord; { Offset in segment }
Selector : SmallWord; { Callgate selector }
end);
2 : (Fwd : record { Forwarder }
ModOrd : SmallWord; { Module ordinal number }
Value : Longint; { Proc name offset or ordinal }
end);
end;
end;
{ Module format directive table }
type
pDirTabRec = ^tDirTabRec;
tDirTabRec = record
DirN : SmallWord;
DataLen : SmallWord;
DataOfs : Longint;
end;
const
dtResident = $8000;
dtVerify = $0001;
dtLangInfo = $0002;
dtCoProc = $0003;
dtThreadSt = $0004;
dtCSetBrws = $0005;
const
fixEnt16 = 3;
fixEnt32 = 5;
gateEnt16 = 5;
fwdEnt = 7;
{ BUNDLE TYPES }
const
btEmpty = $00; { Empty bundle }
btEntry16 = $01; { 16-bit offset entry point }
btGate16 = $02; { 286 call gate (16-bit IOPL) }
btEntry32 = $03; { 32-bit offset entry point }
btEntryFwd = $04; { Forwarder entry point }
btTypeInfo = $80; { Typing information present flag }
{ Format for lxEflags }
{ }
{ 7 6 5 4 3 2 1 0 - bit no }
{ | | | | | | | | }
{ | | | | | | | +--- exported entry }
{ | | | | | | +----- uses shared data }
{ +-+-+-+-+-+------- parameter word count }
const
lxExport = $01; { Exported entry }
lxShared = $02; { Uses shared data }
lxParams = $F8; { Parameter word count mask }
{ Flags for forwarders only: }
const
fwd_Ordinal = $01; { Imported by ordinal }
{Name table entry record used to keep name table in memory}
type
pNameTblRec = ^tNameTblRec;
tNameTblRec = record
Name : pString;
Ord : SmallWord;
end;
{Structure used to keep entry table in memory}
type
pEntBundleRec = ^tEntBundleRec;
tEntBundleRec = record
Header : tEntryTblRec;
DataSz : Longint;
Data : pArrOfByte;
end;
const
{ tLX object error codes }
lxeOK = 0;
lxeReadError = 1;
lxeWriteError = 2;
lxeBadFormat = 3;
lxeBadRevision = 4;
lxeBadOrdering = 5;
lxeInvalidCPU = 6;
lxeBadOS = 7;
lxeUnkEntBundle = 8; {Unknown entry bundle type}
lxeUnkPageFlags = 9; {Unknown page flags}
lxeInvalidPage = 10; {PageSize > 0 and Page is nil}
lxeNoMemory = 11;
lxeInvalidStub = 12;
lxeEAreadError = 13;
lxeEAwriteError = 14;
{ tLX.Save flags definistion }
svfAlignFirstObj = $00000003;{First object alignment AND mask}
svfFOalnShift = $00000000;{Align 1st object on lxPageShift bound}
svfFOalnNone = $00000001;{Do not align 1st object at all}
svfFOalnSector = $00000002;{Align 1st object on sector bound}
svfAlignEachObj = $0000000C;{Other objects alignment AND mask}
svfEOalnShift = $00000000;{Align objects on lxPageShift bound}
svfEOalnSector = $00000008;{Align objects on sector bound}
{ tLX.Pack flags definistion }
pkfRunLengthLvl = $00000003;{Run-length pack method mask}
pkfRunLengthMin = $00000000;{Find only 1-length repeated data}
pkfRunLengthMid = $00000001;{Find data patterns up to 16 chars length}
pkfRunLengthMax = $00000002;{Find ALL matching data (VERY SLOW!)}
pkfRunLength = $00000010;{Pack using run-length packing}
pkfLempelZiv = $00000020;{Pack using kinda Lempel-Ziv(WARP ONLY!)}
type
pArrOfOT = ^tArrOfOT;
tArrOfOT = array[1..99] of tObjTblRec;
pArrOfOM = ^tArrOfOM;
tArrOfOM = array[1..99] of tObjMapRec;
pArrOfRS = ^tArrOfRS;
tArrOfRS = array[1..99] of tResource;
pArrOfMD = ^tArrOfMD;
tArrOfMD = array[1..99] of tDirTabRec;
tProgressFunc = function(Current,Max : Longint) : boolean;
pLX = ^tLX;
tLX = object(tObject)
Stub : pArrOfByte;
StubSize : Longint;
TimeStamp : Longint;
FileAttr : Longint;
Header : tLXheader;
ObjTable : pArrOfOT;
ObjMap : pArrOfOM;
RsrcTable : pArrOfRS;
ResNameTbl : pDarray;
NResNameTbl : pDarray;
EntryTbl : pDarray;
ModDirTbl : pArrOfMD;
PerPageCRC : pArrOfLong;
FixPageTbl : pArrOfLong;
FixRecTbl : pArrOfByte;
FixRecTblSz : Longint;
ImpModTbl : pDarray;
ImpProcTbl : pDarray;
Pages : pArrOfPtr;
PageOrder : pArrOfLong;
DebugInfo : pArrOfByte;
Overlay : pArrOfByte;
OverlaySize : Longint;
EA : pDarray;
constructor Init;
procedure Zero; virtual;
function Load(const fName : string) : Byte;
function Save(const fName : string; saveFlags : Longint) : Byte;
procedure Unpack;
procedure Pack(packFlags : longint; Progress : tProgressFunc);
function ImportModuleTableSize : Longint;
procedure FreeModule;
procedure MinimizePage(PageNo : Longint);
function UsedPage(PageNo : Longint) : boolean;
function isPacked(newAlign,newStubSize,packFlags,saveFlags,oldDbgOfs : longint) : boolean;
destructor Done;virtual;
end;
Implementation uses Dos, os2base, Helpers;
constructor tLX.Init;
begin
Zero;
end;
procedure tLX.Zero;
begin
inherited Zero;
Header.lxMagic := lxfMagic;
{Header.lxBOrder := lxLEBO;}
{Header.lxWOrder := lxLEWO;}
{Header.lxLevel := 0;} {commented out since they`re already zeros}
Header.lxCpu := lxCPU386;
Header.lxOS := 1;
Header.lxPageShift := 2;
end;
{* Two utility procedures for the QuickSort routine: *}
{* compare two pages and exchange two pages (below). *}
Function lxCmpPages(var Buff; N1,N2 : longint) : boolean;
var L1,L2 : Longint;
begin
lxCmpPages := _ON;
with tLX(Buff) do
begin
with ObjMap^[PageOrder^[N1]] do
case PageFlags of
pgValid : L1 := Header.lxDataPageOfs + PageDataOffset shl Header.lxPageShift;
pgIterData,
pgIterData2 : L1 := Header.lxIterMapOfs + PageDataOffset shl Header.lxPageShift;
pgInvalid,
pgZeroed : L1 := $7FFFFFFF;
end;
with ObjMap^[PageOrder^[N2]] do
case PageFlags of
pgValid : L2 := Header.lxDataPageOfs + PageDataOffset shl Header.lxPageShift;
pgIterData,
pgIterData2 : L2 := Header.lxIterMapOfs + PageDataOffset shl Header.lxPageShift;
pgInvalid,
pgZeroed : L2 := $7FFFFFFF;
end;
if (L1 >= L2) or ((L1 = L2) and (N1 >= N2)) then exit;
end;
lxCmpPages := _OFF;
end;
Procedure lxXchgPages(var Buff; N1,N2 : longint);
begin
with tLX(Buff) do
XchgL(PageOrder^[N1], PageOrder^[N2]);
end;
function tLX.Load;
label locEx;
var F : File;
fSz,lastData,I,
J,L : Longint;
S : String;
NTR : pNameTblRec;
EBR : pEntBundleRec;
Res : Byte;
Procedure UpdateLast;
var A : Longint;
begin
A := FilePos(F);
if (lastData < A) and (A <= fSz) then lastData := A;
end;
begin
freeModule;
Res := lxeReadError;
Assign(F, fName);
if not ReadEAs(fName, EA) then begin Res := lxeEAreadError; GoTo locEx; end;
I := FileMode; FileMode := open_share_DenyWrite;
GetFAttr(F, FileAttr); Reset(F, 1); FileMode := I;
if inOutRes <> 0 then GoTo locEx;
Res := lxeBadFormat;
L := 0; lastData := 0;
fSz := FileSize(F);
GetFTime(F, TimeStamp);
repeat
FillChar(Header, sizeOf(Header), 0);
BlockRead(F, Header, sizeOf(Header));
if inOutRes <> 0 then GoTo locEx;
case Header.lxMagic of
lxfMagic : break;
exeMagic1,
exeMagic2 : begin
if pArrOfLong(@header)^[$0F] <= L then GoTo locEx;
L := pArrOfLong(@header)^[$0F];
if L > fSz - sizeOf(Header) then GoTo locEx;
Seek(F, L); {Skip DOS stub}
end;
else GoTo locEx;
end;
until _OFF;
if (Header.lxBOrder <> lxLEBO) or (Header.lxWOrder <> lxLEBO)
then begin Res := lxeBadOrdering; GoTo locEx; end;
if (Header.lxCPU < lxCPU286) or (Header.lxCPU > lxCPUP5)
then begin Res := lxeInvalidCPU; GoTo locEx; end;
if (Header.lxLevel <> 0)
then begin Res := lxeBadRevision; GoTo locEx; end;
if (Header.lxOS <> 1) {Not for OS/2}
then begin Res := lxeBadOS; GoTo locEx; end;
{ Read in DOS stub }
stubSize := L; Seek(F, 0);
GetMem(Stub, stubSize);
BlockRead(F, Stub^, stubSize);
updateLast;
{ Read Object Table }
if (Header.lxObjTabOfs <> 0) and (Header.lxObjTabOfs <= fSz)
then begin
Seek(F, StubSize + Header.lxObjTabOfs);
GetMem(ObjTable, Header.lxObjCnt * sizeOf(tObjTblRec));
BlockRead(F, ObjTable^, Header.lxObjCnt * sizeOf(tObjTblRec));
updateLast;
end;
{ Read Object Page Map Table }
if (Header.lxObjTabOfs <> 0) and (Header.lxObjTabOfs <= fSz)
then begin
Seek(F, StubSize + Header.lxObjMapOfs);
GetMem(ObjMap, Header.lxMpages * sizeOf(tObjMapRec));
BlockRead(F, ObjMap^, Header.lxMpages * sizeOf(tObjMapRec));
updateLast;
end;
if (Header.lxRsrcTabOfs <> 0) and (Header.lxRsrcTabOfs <= fSz)
then begin
Seek(F, StubSize + Header.lxRsrcTabOfs);
GetMem(RsrcTable, Header.lxRsrcCnt * sizeOf(tResource));
BlockRead(F, RsrcTable^, Header.lxRsrcCnt * sizeOf(tResource));
updateLast;
end;
New(ResNameTbl, Init(10));
if (Header.lxResTabOfs <> 0) and (Header.lxResTabOfs <= fSz)
then begin
Seek(F, StubSize + Header.lxResTabOfs);
repeat
BlockRead(F, S, sizeOf(Byte));
if S = '' then break;
BlockRead(F, S[1], length(S));
New(NTR);
NTR^.Name := NewStr(S);
BlockRead(F, NTR^.Ord, sizeOf(SmallWord));
ResNameTbl^.AddItem(NTR);
until inOutRes <> 0;
updateLast;
end;
New(NResNameTbl, Init(10));
if (Header.lxNResTabOfs <> 0) and (Header.lxNResTabOfs <= fSz)
then begin
Seek(F, Header.lxNResTabOfs);
repeat
BlockRead(F, S, sizeOf(Byte));
if S = '' then break;
BlockRead(F, S[1], length(S));
New(NTR);
NTR^.Name := NewStr(S);
BlockRead(F, NTR^.Ord, sizeOf(SmallWord));
NResNameTbl^.AddItem(NTR);
until inOutRes <> 0;
updateLast;
end;
New(EntryTbl, Init(10));
if (Header.lxEntTabOfs <> 0) and (Header.lxEntTabOfs <= fSz)
then begin
Seek(F, StubSize + Header.lxEntTabOfs);
repeat
New(EBR);
BlockRead(F, EBR^.Header.Count, sizeOf(EBR^.Header.Count));
if EBR^.Header.Count = 0
then begin Dispose(EBR); break; end;
BlockRead(F, EBR^.Header.BndType, sizeOf(EBR^.Header.BndType));
case EBR^.Header.BndType of
btEmpty : EBR^.DataSz := 0;
btEntry16 : EBR^.DataSz := EBR^.Header.Count * fixEnt16;
btGate16 : EBR^.DataSz := EBR^.Header.Count * gateEnt16;
btEntry32 : EBR^.DataSz := EBR^.Header.Count * fixEnt32;
btEntryFwd : EBR^.DataSz := EBR^.Header.Count * fwdEnt;
else begin Res := lxeUnkEntBundle; Dispose(EBR); GoTo locEx; end;
end;
if EBR^.DataSz <> 0
then BlockRead(F, EBR^.Header.Obj, sizeOf(EBR^.Header.Obj));
GetMem(EBR^.Data, EBR^.DataSz);
BlockRead(F, EBR^.Data^, EBR^.DataSz);
EntryTbl^.AddItem(EBR);
until inOutRes <> 0;
updateLast;
end;
if (Header.lxDirTabOfs <> 0) and (Header.lxDirTabOfs <= fSz)
then begin
Seek(F, StubSize + Header.lxDirTabOfs);
GetMem(ModDirTbl, Header.lxDirCnt * sizeOf(tResource));
BlockRead(F, ModDirTbl^, Header.lxDirCnt * sizeOf(tResource));
updateLast;
end;
if Header.lxPageSumOfs <> 0
then begin
Seek(F, StubSize + Header.lxPageSumOfs);
GetMem(PerPageCRC, Header.lxMpages * sizeOf(Longint));
BlockRead(F, PerPageCRC^, Header.lxMpages * sizeOf(Longint));
updateLast;
end;
if Header.lxFPageTabOfs <> 0
then begin
Seek(F, StubSize + Header.lxFPageTabOfs);
GetMem(FixPageTbl, succ(Header.lxMpages) * sizeOf(Longint));
BlockRead(F, FixPageTbl^, succ(Header.lxMpages) * sizeOf(Longint));
updateLast;
end;
New(ImpModTbl, Init(10));
if Header.lxImpModOfs <> 0
then begin
Seek(F, StubSize + Header.lxImpModOfs);
For I := 1 to Header.lxImpModCnt do
begin
BlockRead(F, S, sizeOf(Byte));
BlockRead(F, S[1], length(S));
ImpModTbl^.AddItem(NewStr(S));
end;
updateLast;
end;
New(ImpProcTbl, Init(10));
if Header.lxImpProcOfs <> 0
then begin
Seek(F, StubSize + Header.lxImpProcOfs);
I := Header.lxFPageTabOfs + Header.lxFixupSize - Header.lxImpProcOfs;
While I > 0 do
begin
BlockRead(F, S, sizeOf(Byte));
BlockRead(F, S[1], length(S));
ImpProcTbl^.AddItem(NewStr(S));
Dec(I, succ(length(S)));
end;
updateLast;
end;
if Header.lxFRecTabOfs <> 0
then begin
Seek(F, StubSize + Header.lxFRecTabOfs);
FixRecTblSz := Header.lxImpModOfs - (Header.lxFPageTabOfs +
succ(Header.lxMpages) * sizeOf(Longint));
GetMem(FixRecTbl, FixRecTblSz);
BlockRead(F, FixRecTbl^, FixRecTblSz);
updateLast;
end;
GetMem(Pages, Header.lxMpages * sizeOf(Pointer));
FillChar(Pages^, Header.lxMpages * sizeOf(Pointer), 0);
GetMem(PageOrder, Header.lxMpages * sizeOf(Longint));
For I := 1 to Header.lxMpages do
with ObjMap^[I] do
begin
PageOrder^[pred(I)] := I;
case PageFlags of
pgValid : L := Header.lxDataPageOfs;
pgIterData,
pgIterData2 : L := Header.lxIterMapOfs;
pgInvalid,
pgZeroed : begin
PageDataOffset := 0;
L := -1;
end;
else{pgRange} begin Res := lxeUnkPageFlags; GoTo locEx; end;
end;
if L <> -1
then begin
Inc(L, PageDataOffset shl Header.lxPageShift);
if (L > fSz)
then if UsedPage(I)
then goto locEx
else begin
PageSize := 0;
PageDataOffset := 0;
PageFlags := pgInvalid;
end
else begin
Seek(F, L);
GetMem(Pages^[pred(I)], PageSize);
BlockRead(F, Pages^[pred(I)]^, PageSize);
updateLast;
end;
end;
end;
{ Now sort the pages in the order they come in the file }
QuickSort(Self, 0, pred(Header.lxMpages), 0, lxCmpPages, lxXchgPages);
if Header.lxDebugInfoOfs <> 0
then if Header.lxDebugInfoOfs >= fSz
then Header.lxDebugInfoOfs := 0
else begin
Seek(F, Header.lxDebugInfoOfs);
GetMem(DebugInfo, Header.lxDebugLen);
BlockRead(F, DebugInfo^, Header.lxDebugLen);
updateLast;
end;
OverlaySize := fSz - lastData;
GetMem(Overlay, OverlaySize);
Seek(F, lastData);
BlockRead(F, Overlay^, OverlaySize);
if inOutRes <> 0 then GoTo locEx;
Res := lxeOK;
locEx:
if ioResult <> 0 then Res := lxeReadError;
if Res <> lxeOK then freeModule;
Load := Res;
Close(F); inOutRes := 0;
end;
function tLX.Save;
label locEx;
var F : File;
Res : Byte;
I,J,
K,L : Longint;
pL : pLong;
NTR : pNameTblRec;
EBR : pEntBundleRec;
ZeroB: pArrOfByte;
ZeroL: Longint;
begin
{ The following fields in Header must be set up before Save: }
{ lxMpages lxStartObj lxEIP lxStackObj
lxESP lxPageSize lxPageShift lxObjCnt
lxRsrcCnt lxDirCnt lxAutoData }
Header.lxFixupSum := 0;
Header.lxLdrSum := 0;
Header.lxNResSum := 0;
{lxInstPreload := 0;{*}
{lxInstDemand := 0;{*}
{lxHeapSize := 0;{*}
if SaveFlags and svfAlignEachObj = svfEOalnSector
then begin
SaveFlags := (SaveFlags and not svfAlignFirstObj) or svfFOalnSector;
if Header.lxPageShift < 9 then Header.lxPageShift := 9;
end;
if (SaveFlags and svfAlignFirstObj = svfFOalnSector) and (Header.lxPageShift < 9)
then ZeroL := 512
else ZeroL := 1 shl Header.lxPageShift;
GetMem(ZeroB, ZeroL);
if ZeroB = nil then begin Res := lxeNoMemory; GoTo locEx; end;
FillChar(ZeroB^, ZeroL, 0);
Res := lxeOK; I := FileMode;
FileMode := open_access_ReadWrite or open_share_DenyReadWrite;
Assign(F, fName); SetFattr(F, 0); inOutRes := 0;
Rewrite(F, 1); FileMode := I; if inOutRes <> 0 then Goto locEx;
{ Write stub to file. }
if ((Stub = nil) and (StubSize <> 0)) or ((StubSize < $40) and (StubSize > 0))
then begin Res := lxeInvalidStub; Goto locEx; end;
if (Stub <> nil)
then begin
pArrOfLong(Stub)^[$0F] := StubSize;
BlockWrite(F, Stub^, StubSize);
end;
{ Temporary skip header }
Seek(F, StubSize + sizeOf(Header));
{ Write Object Table }
if ObjTable <> nil
then begin
Header.lxObjTabOfs := FilePos(F) - StubSize;
BlockWrite(F, ObjTable^, Header.lxObjCnt * sizeOf(tObjTblRec));
end
else Header.lxObjTabOfs := 0;
{ Temporary skip Object Page Map Table }
Seek(F, FilePos(F) + Header.lxMpages * sizeOf(tObjMapRec));
{ Write resource table }
if RsrcTable <> nil
then begin
Header.lxRsrcTabOfs := FilePos(F) - StubSize;
BlockWrite(F, RsrcTable^, Header.lxRsrcCnt * sizeOf(tResource));
end
else Header.lxRsrcTabOfs := 0;
{ Write resident name table }
Header.lxResTabOfs := FilePos(F) - StubSize;
For I := 1 to ResNameTbl^.numItems do
begin
NTR := ResNameTbl^.GetItem(I);
BlockWrite(F, NTR^.Name^, succ(length(NTR^.Name^)));
BlockWrite(F, NTR^.Ord, sizeOf(SmallWord));
end;
I := 0; BlockWrite(F, I, sizeOf(Byte));
{ Write module entry table }
Header.lxEntTabOfs := FilePos(F) - StubSize;
For I := 1 to EntryTbl^.numItems do
begin
EBR := EntryTbl^.GetItem(I);
BlockWrite(F, EBR^.Header.Count, sizeOf(EBR^.Header.Count));
BlockWrite(F, EBR^.Header.BndType, sizeOf(EBR^.Header.BndType));
if EBR^.DataSz <> 0
then BlockWrite(F, EBR^.Header.Obj, sizeOf(EBR^.Header.Obj));
BlockWrite(F, EBR^.Data^, EBR^.DataSz);
end;
I := 0; BlockWrite(F, I, sizeOf(EBR^.Header.Count));
{ Write module directives table }
if ModDirTbl <> nil
then begin
Header.lxDirTabOfs := FilePos(F) - StubSize;
BlockWrite(F, ModDirTbl^, Header.lxDirCnt * sizeOf(tResource));
end
else Header.lxDirTabOfs := 0;
{ Write per-page checksum }
if PerPageCRC <> nil
then begin
Header.lxPageSumOfs := FilePos(F) - StubSize;
BlockWrite(F, PerPageCRC^, Header.lxMpages * sizeOf(Longint));
end
else Header.lxPageSumOfs := 0;
Header.lxLdrSize := FilePos(F) - Header.lxObjTabOfs - StubSize;
{ Write page fixup table }
L := FilePos(F);
Header.lxFPageTabOfs := FilePos(F) - StubSize;
BlockWrite(F, FixPageTbl^, succ(Header.lxMpages) * sizeOf(Longint));
{ Write fixup record table }
Header.lxFRecTabOfs := FilePos(F) - StubSize;
BlockWrite(F, FixRecTbl^, FixRecTblSz);
{ Write imported modules table }
Header.lxImpModOfs := FilePos(F) - StubSize;
Header.lxImpModCnt := ImpModTbl^.numItems;
For I := 1 to Header.lxImpModCnt do
if ImpModTbl^.GetItem(I) <> nil
then BlockWrite(F, ImpModTbl^.GetItem(I)^,
succ(length(pString(ImpModTbl^.GetItem(I))^)))
else BlockWrite(F, ZeroB^, 1);
{ Write imported procedures table }
Header.lxImpProcOfs := FilePos(F) - StubSize;
For I := 1 to ImpProcTbl^.numItems do
if ImpProcTbl^.GetItem(I) <> nil
then BlockWrite(F, ImpProcTbl^.GetItem(I)^,
succ(length(pString(ImpProcTbl^.GetItem(I))^)))
else BlockWrite(F, ZeroB^, 1);
{ Calculate fixup section size }
Header.lxFixupSize := FilePos(F) - L;
{ Now write the data/code pages }
L := FilePos(F);
case SaveFlags and svfAlignFirstObj of
svfFOalnNone : I := L;
svfFOalnShift : I := (L + pred(1 shl Header.lxPageShift)) and
($FFFFFFFF shl Header.lxPageShift);
svfFOalnSector : I := (L + 511) and $FFFFFE00;
end;
BlockWrite(F, ZeroB^, I - L);
Header.lxDataPageOfs := 0;
Header.lxIterMapOfs := 0;
Header.lxDataPageOfs := FilePos(F);
For I := 1 to Header.lxMpages do
begin
K := PageOrder^[pred(I)];
with ObjMap^[K] do
begin
case PageFlags of
pgValid : pL := @Header.lxDataPageOfs;
pgIterData,
pgIterData2 : begin
Header.lxIterMapOfs := Header.lxDataPageOfs;
pL := @Header.lxIterMapOfs;
end;
pgInvalid,
pgZeroed : pL := nil;
else{pgRange} begin Res := lxeUnkPageFlags; GoTo locEx; end;
end;
if pL <> nil
then begin
if (Pages^[pred(K)] = nil) and (PageSize <> 0)
then begin Res := lxeInvalidPage; GoTo locEx; end;
MinimizePage(K);
J := FilePos(F);
L := (J - pL^ + pred(1 shl Header.lxPageShift)) and
($FFFFFFFF shl Header.lxPageShift);
if pL^ + L > J then BlockWrite(F, ZeroB^, pL^ + L - J);
PageDataOffset := L shr Header.lxPageShift;
BlockWrite(F, Pages^[pred(K)]^, PageSize);
end
else PageDataOffset := 0;
end;
end;
{ And now write the non-resident names table }
if NResNameTbl^.numItems > 0
then begin
Header.lxNResTabOfs := FilePos(F);
For I := 1 to NResNameTbl^.numItems do
begin
NTR := NResNameTbl^.GetItem(I);
BlockWrite(F, NTR^.Name^, succ(length(NTR^.Name^)));
BlockWrite(F, NTR^.Ord, sizeOf(SmallWord));
end;
I := 0; BlockWrite(F, I, sizeOf(Byte));
Header.lxCbNResTabOfs := FilePos(F) - Header.lxNResTabOfs;
end
else begin
Header.lxNResTabOfs := 0;
Header.lxCbNResTabOfs := 0;
end;
if Header.lxDebugInfoOfs <> 0
then begin
Header.lxDebugInfoOfs := FilePos(F);
BlockWrite(F, DebugInfo^, Header.lxDebugLen);
end;
if OverlaySize <> 0
then BlockWrite(F, Overlay^, OverlaySize);
Seek(F, StubSize + sizeOf(Header) + Header.lxObjCnt * sizeOf(tObjTblRec));
{ Now write Object Page Map Table }
if ObjMap <> nil
then begin
Header.lxObjMapOfs := FilePos(F) - StubSize;
BlockWrite(F, ObjMap^, Header.lxMpages * sizeOf(tObjMapRec));
end
else Header.lxObjMapOfs := 0;
{ Now seek to beginning and write the LX header }
Seek(F, StubSize);
BlockWrite(F, Header, sizeOf(Header));
locEx:
if ZeroB <> nil then FreeMem(ZeroB, ZeroL);
if ioResult <> 0 then Res := lxeWriteError;
if TimeStamp <> 0 then SetFTime(F, TimeStamp);
Save := Res; Close(F); inOutRes := 0;
if FileAttr <> 0 then SetFattr(F, FileAttr);
if (Res = lxeOK) and (not WriteEAs(fName, EA))
then Save := lxeEAwriteError;
end;
procedure tLX.freeModule;
var I : Longint;
NTR : pNameTblRec;
EBR : pEntBundleRec;
begin
if PageOrder <> nil
then FreeMem(PageOrder, Header.lxMpages * sizeOf(Pointer));
if Pages <> nil
then begin
For I := 1 to Header.lxMpages do
if Pages^[pred(I)] <> nil
then FreeMem(Pages^[pred(I)], ObjMap^[I].PageSize);
FreeMem(Pages, Header.lxMpages * sizeOf(Pointer));
end;
if FixRecTbl <> nil
then FreeMem(FixRecTbl, FixRecTblSz);
if ImpProcTbl <> nil
then begin
For I := 1 to ImpProcTbl^.numItems do
if ImpProcTbl^.GetItem(I) <> nil
then DisposeStr(ImpProcTbl^.GetItem(I));
Dispose(ImpProcTbl, Done);
end;
if ImpModTbl <> nil
then begin
For I := 1 to ImpModTbl^.numItems do
if ImpModTbl^.GetItem(I) <> nil
then DisposeStr(ImpModTbl^.GetItem(I));
Dispose(ImpModTbl, Done);
end;
if FixPageTbl <> nil
then FreeMem(FixPageTbl, succ(Header.lxMpages) * sizeOf(Longint));
if PerPageCRC <> nil
then FreeMem(PerPageCRC, Header.lxMpages * sizeOf(Longint));
if ModDirTbl <> nil
then FreeMem(ModDirTbl, Header.lxDirCnt * sizeOf(tResource));
if EntryTbl <> nil
then begin
For I := 1 to EntryTbl^.numItems do
begin
EBR := EntryTbl^.GetItem(I);
FreeMem(EBR^.Data, EBR^.DataSz);
Dispose(EBR);
end;
Dispose(EntryTbl, Done);
end;
if NResNameTbl <> nil
then begin
For I := 1 to NResNameTbl^.numItems do
begin
NTR := NResNameTbl^.GetItem(I);
DisposeStr(NTR^.Name);
Dispose(NTR);
end;
Dispose(NResNameTbl, Done);
end;
if ResNameTbl <> nil
then begin
For I := 1 to ResNameTbl^.numItems do
begin
NTR := ResNameTbl^.GetItem(I);
DisposeStr(NTR^.Name);
Dispose(NTR);
end;
Dispose(ResNameTbl, Done);
end;
if RsrcTable <> nil
then FreeMem(RsrcTable, Header.lxRsrcCnt * sizeOf(tResource));
if ObjMap <> nil
then FreeMem(ObjMap, Header.lxMpages * sizeOf(tObjMapRec));
if ObjTable <> nil
then FreeMem(ObjTable, Header.lxObjCnt * sizeOf(tObjTblRec));
if stubSize <> 0
then FreeMem(Stub, StubSize);
if OverlaySize <> 0
then FreeMem(Overlay, OverlaySize);
if EA <> nil then FreeEAs(EA);
Zero;
end;
function tLX.ImportModuleTableSize;
var I,L : Longint;
begin
L := 0;
For I := 1 to ImpModTbl^.numItems do
Inc(L, succ(length(pString(ImpModTbl^.GetItem(I))^)));
ImportModuleTableSize := L;
end;
Function UnpackMethod1(var srcData, destData; srcDataSize : Longint;
var dstDataSize : longint) : boolean;
var src : tArrOfByte absolute srcData;
dst : tArrOfByte absolute destData;
sOf,dOf : Longint;
nI,cB : SmallWord;
Function srcAvail(N : Longint) : boolean;
begin
srcAvail := sOf + N <= srcDataSize;
end;
Function dstAvail(N : Longint) : boolean;
begin
dstAvail := dOf + N <= dstDataSize;
end;
begin
UnpackMethod1 := _OFF;
sOf := 0; dOf := 0;
repeat
if not srcAvail(1) then break;
if not srcAvail(2+2) then exit;
nI := pSmallWord(@src[sOf])^;
cB := pSmallWord(@src[sOf+2])^;
Inc(sOf, 2+2);
if srcAvail(cB) and dstAvail(cB * nI)
then if nI > 0
then begin
linearMove(src[sOf], dst[dOf], cB);
linearMove(dst[dOf], dst[dOf + cB], cB * pred(nI));
Inc(dOf, cB * nI);
end
else
else exit;
Inc(sOf, cB);
until dOf >= dstDataSize;
FillChar(dst[dOf], dstDataSize - dOf, 0);
dstDataSize := dOf;
UnpackMethod1 := _ON;
end;
Function UnpackMethod2(var srcData, destData; srcDataSize : Longint;
var dstDataSize : Longint) : boolean;
var src : tArrOfByte absolute srcData;
dst : tArrOfByte absolute destData;
B1,B2 : Byte;
sOf,dOf,
bOf : Longint;
Function srcAvail(N : Longint) : boolean;
begin
srcAvail := sOf + N <= srcDataSize;
end;
Function dstAvail(N : Longint) : boolean;
begin
dstAvail := dOf + N <= dstDataSize;
end;
begin
UnpackMethod2 := _OFF;
sOf := 0; dOf := 0;
repeat
if not srcAvail(1) then break;
B1 := src[sOf];
case B1 and 3 of
0 : if B1 = 0
then if srcAvail(2)
then if src[succ(sOf)] = 0
then begin Inc(sOf, 2); break; end
else if srcAvail(3) and dstAvail(src[succ(sOf)])
then begin
FillChar(dst[dOf], src[succ(sOf)], src[sOf+2]);
Inc(sOf, 3); Inc(dOf, src[sOf-2]);
end
else exit
else exit
else if srcAvail(succ(B1 shr 2)) and dstAvail(B1 shr 2)
then begin
linearMove(src[succ(sOf)], dst[dOf], B1 shr 2);
Inc(dOf, B1 shr 2);
Inc(sOf, succ(B1 shr 2));
end
else exit;
1 : begin
if not srcAvail(2) then exit;
bOf := pSmallWord(@src[sOf])^ shr 7;
B2 := (B1 shr 4) and 7 + 3;
B1 := (B1 shr 2) and 3;
if srcAvail(2 + B1) and dstAvail(B1 + B2) and (dOf + B1 - bOf >= 0)
then begin
linearMove(src[sOf + 2], dst[dOf], B1);
Inc(dOf, B1); Inc(sOf, 2 + B1);
linearMove(dst[dOf - bOf], dst[dOf], B2);
Inc(dOf, B2);
end
else exit;
end;
2 : begin
if not srcAvail(2) then exit;
bOf := pSmallWord(@src[sOf])^ shr 4;
B1 := (B1 shr 2) and 3 + 3;
if dstAvail(B1) and (dOf - bOf >= 0)
then begin
linearMove(dst[dOf - bOf], dst[dOf], B1);
Inc(dOf, B1); Inc(sOf, 2);
end
else exit;
end;
3 : begin
if not srcAvail(3) then exit;
B2 := (pSmallWord(@src[sOf])^ shr 6) and $3F;
B1 := (src[sOf] shr 2) and $0F;
bOf := pSmallWord(@src[succ(sOf)])^ shr 4;
if srcAvail(3 + B1) and dstAvail(B1 + B2) and (dOf + B1 - bOf >= 0)
then begin
linearMove(src[sOf + 3], dst[dOf], B1);
Inc(dOf, B1); Inc(sOf, 3 + B1);
linearMove(dst[dOf - bOf], dst[dOf], B2);
Inc(dOf, B2);
end
else exit;
end;
end;
until dOf >= dstDataSize;
FillChar(dst[dOf], dstDataSize - dOf, 0);
dstDataSize := dOf;
UnpackMethod2 := _ON;
end;
procedure tLX.Unpack;
var I,J : Longint;
uD,pD : pArrOfByte;
UnpFunc : Function(var srcData, destData; srcDataSize : longint; var dstDataSize : Longint) : boolean;
begin
For I := 1 to Header.lxMpages do
with ObjMap^[I] do
begin
case PageFlags of
pgIterData : @UnpFunc := @UnpackMethod1;
pgIterData2 : @UnpFunc := @UnpackMethod2;
pgValid : @UnpFunc := nil;
else Continue;
end;
pD := Pages^[pred(I)];
if @UnpFunc <> nil
then begin
GetMem(uD, Header.lxPageSize); J := Header.lxPageSize;
if UnpFunc(pD^, uD^, PageSize, J)
then begin
FreeMem(pD, PageSize);
GetMem(pD, J);
linearMove(uD^, pD^, J);
PageSize := J;
PageFlags := pgValid;
Pages^[pred(I)] := pD;
end;
FreeMem(uD, Header.lxPageSize); {Unpack error}
end;
J := PageSize;
While (J > 0) and (pD^[pred(J)] = 0) do Dec(J);
if J <> PageSize
then begin
GetMem(uD, J);
Move(pD^, uD^, J);
Pages^[pred(I)] := uD;
FreeMem(pD, PageSize);
PageSize := J;
end;
end;
end;
function PackMethod1(var srcData,dstData; srcDataSize : longint;
var dstDataSize : Longint; packLevel : byte) : boolean;
var sOf,dOf,tOf,
MatchOff,
MatchCnt,
MatchLen : Longint;
src : tArrOfByte absolute srcData;
dst : tArrOfByte absolute dstData;
{$uses ebx,esi,edi}
{!workaround!}
{This procedure ACCESSES external data (tOf for example)}
{but VP beta does not update the EBP register}
function Search : boolean; assembler;
asm cld
mov esi,srcData
mov edi,esi
add edi,tOf[-4] {!!! and so on !!!}
add esi,sOf[-4]
xor eax,eax
movzx ecx,packLevel
cmp cl,255
je @@setStart
mov ebx,edi
sub ebx,esi
cmp ebx,ecx
jbe @@setStart
mov eax,ebx
sub eax,ecx
@@setStart: mov MatchOff[-4],eax
add esi,eax
@@nextPatt: push esi
push edi
mov eax,srcDataSize
sub eax,tOf[-4]
mov ebx,edi
sub ebx,esi
cmp ebx,eax
ja @@noMatch
xor edx,edx
div ebx
mov edx,eax {EDX = EAX = max matches}
@@nextMatch: mov ecx,ebx {EBX = ECX = pattern length}
repe cmpsb
jne @@notEQ
dec eax
jnz @@nextMatch
@@notEQ: cmp eax,edx
je @@noMatch
sub eax,edx
neg eax
inc eax {EAX = number of actual matches}
mov edx,ebx
db $0F,$AF,$D8 {imul ebx,eax}
sub ebx,2+2
jc @@noMatch
cmp ebx,edx
jbe @@noMatch
mov MatchCnt[-4],eax
mov MatchLen[-4],edx
pop esi
pop edi
mov al,1
jmp @@locEx
@@noMatch: pop edi
pop esi
inc esi
inc MatchOff[-4]
cmp esi,edi
jb @@nextPatt
mov al,0
@@locEx:
end;
{$uses none}
function dstAvail(N : Longint) : boolean;
begin
dstAvail := dOf + N <= dstDataSize;
end;
function PutNonpackedData : boolean;
begin
PutNonpackedData := _ON;
if MatchOff > 0
then if dstAvail(2+2+MatchOff)
then begin
pSmallWord(@dst[dOf])^ := 1; Inc(dOf, 2);
pSmallWord(@dst[dOf])^ := MatchOff; Inc(dOf, 2);
Move(src[sOf], dst[dOf], MatchOff);
Inc(dOf, MatchOff); Inc(sOf, MatchOff);
end
else PutNonpackedData := _OFF;
end;
begin
PackMethod1 := _OFF;
sOf := 0; dOf := 0;
repeat
tOf := succ(sOf);
While tOf < srcDataSize do
begin
if Search
then begin
if (not PutNonpackedData) or
(not dstAvail(2+2+MatchLen)) then exit;
pSmallWord(@dst[dOf])^ := MatchCnt; Inc(dOf, 2);
pSmallWord(@dst[dOf])^ := MatchLen; Inc(dOf, 2);
linearMove(src[sOf], dst[dOf], MatchLen);
Inc(sOf, MatchCnt * MatchLen); Inc(dOf, MatchLen);
break;
end
else Inc(tOf);
end;
until tOf >= srcDataSize;
MatchOff := srcDataSize - sOf;
if (not PutNonpackedData) or (sOf <= dOf) then exit;
dstDataSize := dOf;
PackMethod1 := _ON;
end;
function PackMethod2(var srcData,dstData; srcDataSize : longint; var dstDataSize : Longint) : boolean;
label skip,locEx;
var Chain : pArrOfSmallWord;
ChainHead : pArrOfSmallWord;
sOf,dOf,tOf,I,J,
maxMatchLen,
maxMatchPos : Longint;
src : tArrOfByte absolute srcData;
dst : tArrOfByte absolute dstData;
{$uses esi,edi,ebx}
{!workaround!}
{See above}
function Search : boolean; assembler;
asm cld
mov edx,srcDataSize
sub edx,tOf[-4]
mov al,0
cmp edx,2
jbe @@locEx
mov esi,srcData
mov edi,esi
add esi,tOf[-4]
mov ax,[esi]
and eax,0FFFh
shl eax,1
add eax,ChainHead[-4]
and maxMatchLen[-4],0
@@nextSearch: push esi
movsx edi,word ptr [eax]
cmp edi,-1
je @@endOfChain
mov eax,edi
shl eax,1
add eax,Chain[-4]
add edi,srcData
mov ecx,edx
repe cmpsb
jz @@maxLen
pop esi
sub ecx,edx
neg ecx
sub edi,ecx
dec ecx
cmp ecx,maxMatchLen[-4]
jbe @@nextSearch
sub edi,srcData
mov maxMatchLen[-4],ecx
mov maxMatchPos[-4],edi
mov ebx,tOf[-4]
dec ebx
cmp ebx,edi {Prefer RL encoding since it}
jne @@nextSearch {packs longer strings}
cmp ecx,63 {Strings up to 63 chars are always}
jbe @@nextSearch {packed effectively enough}
push esi
jmp @@endOfChain
@@maxLen: sub edi,edx
sub edi,srcData
mov maxMatchLen[-4],edx
mov maxMatchPos[-4],edi
@@endOfChain: mov al,0
cmp maxMatchLen[-4],3
jb @@noMatch
inc al
@@noMatch: pop esi
@@locEx:
end;
{$uses none}
function dstAvail(N : Longint) : boolean;
begin
dstAvail := dOf + N <= dstDataSize;
end;
procedure Register(sOf, Count : Longint);
var I : Longint;
begin
While (Count > 0) and (sOf < pred(srcDataSize)) do
begin
I := pSmallWord(@src[sOf])^ and $FFF;
Chain^[sOf] := ChainHead^[I];
ChainHead^[I] := sOf;
Inc(sOf); Dec(Count);
end;
end;
procedure Deregister(sOf : Longint);
var I : Longint;
begin
I := pSmallWord(@src[sOf])^ and $FFF;
ChainHead^[I] := Chain^[sOf];
end;
begin
PackMethod2 := _OFF;
GetMem(Chain, srcDataSize * 2);
GetMem(ChainHead, (1 shl 12) * 2);
FillChar(ChainHead^, (1 shl 12) * 2, $FF);
sOf := 0; dOf := 0;
repeat
tOf := sOf;
while tOf < srcDataSize do
if Search
then begin
if (maxMatchPos = pred(tOf))
then begin
if tOf > sOf then
begin
Inc(maxMatchLen);
Dec(tOf); Deregister(tOf);
end;
if maxMatchLen = 3 then goto skip;
while sOf < tOf do
begin
I := MinL(tOf - sOf, 63);
if not dstAvail(succ(I)) then goto locEx;
dst[dOf] := I shl 2;
linearMove(src[sOf], dst[succ(dOf)], I);
Inc(sOf, I); Inc(dOf, succ(I));
end;
while maxMatchLen > 3 do
begin
if not dstAvail(3) then goto locEx;
I := MinL(maxMatchLen, 255);
dst[dOf] := 0;
dst[dOf+1] := I;
dst[dOf+2] := src[sOf];
Register(sOf, I);
Inc(sOf, I); Inc(dOf, 3);
Dec(maxMatchLen, I);
end;
end
else begin
if (tOf - maxMatchPos < 512) and (maxMatchLen <= 10)
then J := 3
else
if (maxMatchLen <= 6)
then J := 0
else J := 15;
while (sOf < tOf - J) do
begin
I := MinL(tOf - sOf, 63);
if not dstAvail(succ(I)) then goto locEx;
dst[dOf] := I shl 2;
linearMove(src[sOf], dst[succ(dOf)], I);
Inc(sOf, I); Inc(dOf, succ(I));
end;
case byte(J) of
3 : begin
if not dstAvail(2 + tOf - sOf) then goto locEx;
pSmallWord(@dst[dOf])^ := 1 + (tOf - sOf) shl 2 +
(maxMatchLen - 3) shl 4 + (tOf - maxMatchPos) shl 7;
linearMove(src[sOf], dst[dOf + 2], tOf - sOf);
Register(tOf, maxMatchLen);
Inc(dOf, 2 + tOf - sOf);
sOf := tOf + maxMatchLen;
end;
0 : begin
if not dstAvail(2) then goto locEx;
pSmallWord(@dst[dOf])^ := 2 + (maxMatchLen - 3) shl 2 +
(tOf - maxMatchPos) shl 4;
Register(tOf, maxMatchLen);
Inc(dOf, 2);
sOf := tOf + maxMatchLen;
end;
15 : begin
if not dstAvail(3 + tOf - sOf) then goto locEx;
J := MinL(maxMatchLen, 63);
pSmallWord(@dst[dOf])^ := 3 + (tOf - sOf) shl 2 +
(J shl 6) + (tOf - maxMatchPos) shl 12;
dst[dOf + 2] := (tOf - maxMatchPos) shr 4;
linearMove(src[sOf], dst[dOf + 3], tOf - sOf);
Register(tOf, J);
Inc(dOf, 3 + tOf - sOf);
sOf := tOf + J;
end;
end;
end;
break;
end
else begin
skip: Register(tOf, 1);
Inc(tOf);
end;
until tOf >= srcDataSize;
if not dstAvail(srcDataSize - sOf + 2) then goto locEx;
while sOf < srcDataSize do
begin
I := MinL(srcDataSize - sOf, 63);
if not dstAvail(succ(I)) then goto locEx;
dst[dOf] := I shl 2;
linearMove(src[sOf], dst[succ(dOf)], I);
Inc(sOf, I); Inc(dOf, succ(I));
end;
pSmallWord(@dst[dOf])^ := 0; Inc(dOf, 2); {Put end-of-page flag}
if dOf >= srcDataSize then goto locEx;
PackMethod2 := _ON;
dstDataSize := dOf;
locEx:
FreeMem(ChainHead, (1 shl 12) * 2);
FreeMem(Chain, srcDataSize * 2);
end;
procedure tLX.Pack;
const
maxLen : array[0..2] of Byte = (1, 16, 255);
var I,S1,S2 : Longint;
Bf1,Bf2 : Pointer;
Procedure SetPage(var oD : Pointer; nD : Pointer; var oS : SmallWord; nS : Longint);
begin
FreeMem(oD, oS); oS := nS;
GetMem(Pages^[pred(I)], nS);
Move(nD^, oD^, nS);
end;
begin
GetMem(Bf1, Header.lxPageSize);
GetMem(Bf2, Header.lxPageSize);
For I := 1 to Header.lxMPages do
with ObjMap^[I] do
if (PageFlags = pgValid) and (PageSize > 0)
then begin
if @Progress <> nil then Progress(pred(I), Header.lxMPages);
S1 := Header.lxPageSize; S2 := Header.lxPageSize;
if (packFlags and pkfRunLength = 0) or
(not PackMethod1(Pages^[pred(I)]^, Bf1^, PageSize, S1, maxLen[packFlags and pkfRunLengthLvl]))
then S1 := $7FFFFFFF;
if (packFlags and pkfLempelZiv = 0) or
(not PackMethod2(Pages^[pred(I)]^, Bf2^, PageSize, S2))
then S2 := $7FFFFFFF;
if (S1 < S2) and (S1 < Header.lxPageSize) {RL-coding is effective enough?}
then begin
PageFlags := pgIterData;
SetPage(Pages^[pred(I)], Bf1, PageSize, S1);
end
else
if (S2 < Header.lxPageSize) {May be LZ77 done something?}
then begin
PageFlags := pgIterData2;
SetPage(Pages^[pred(I)], Bf2, PageSize, S2);
end;
end;
if @Progress <> nil then Progress(1, 1);
FreeMem(Bf2, Header.lxPageSize);
FreeMem(Bf1, Header.lxPageSize);
end;
procedure tLX.MinimizePage;
var dOf : Longint;
P : pArrOfByte;
begin
if PageNo > Header.lxMPages then exit;
with ObjMap^[PageNo] do
if PageFlags = pgValid
then begin
dOf := PageSize;
While (dOf > 0) and (pArrOfByte(Pages^[pred(PageNo)])^[pred(dOf)] = 0) do Dec(dOf);
dOf := (dOf + pred(1 shl Header.lxPageShift)) and
($FFFFFFFF shl Header.lxPageShift);
if PageSize <> dOf
then begin
GetMem(P, dOf);
Move(Pages^[pred(pageNo)]^, P^, MinL(dOf, PageSize));
if dOf > PageSize
then FillChar(P^[PageSize], dOf - PageSize, 0);
FreeMem(Pages^[pred(pageNo)], PageSize);
Pages^[pred(pageNo)] := P;
PageSize := dOf;
end;
end;
end;
function tLX.UsedPage;
var I : Longint;
begin
For I := 1 to Header.lxObjCnt do
with ObjTable^[I] do
if (PageNo >= oPageMap) and (PageNo < oPageMap + oMapSize)
then begin UsedPage := _ON; exit; end;
UsedPage := _OFF;
end;
function tLX.isPacked;
var i,j,k,l,
f,cp : Longint;
pl : pLong;
NTR : pNameTblRec;
EBR : pEntBundleRec;
ps : Byte;
begin
isPacked := _OFF;
if (newAlign <> 255) and (newAlign <> header.lxPageShift) then exit;
if (newStubSize <> -1) and (newStubSize <> StubSize) then exit;
if newAlign <> 255 then ps := newAlign else ps := header.lxPageShift;
cp := StubSize + sizeOf(Header);
if ObjTable <> nil
then begin
if Header.lxObjTabOfs <> cp - StubSize then exit;
Inc(cp, Header.lxObjCnt * sizeOf(tObjTblRec));
end;
if ObjMap <> nil
then begin
if Header.lxObjMapOfs <> cp - StubSize then exit;
Inc(cp, Header.lxMpages * sizeOf(tObjMapRec));
end;
if RsrcTable <> nil
then begin
if Header.lxRsrcTabOfs <> cp - StubSize then exit;
Inc(cp, Header.lxRsrcCnt * sizeOf(tResource));
end;
if Header.lxResTabOfs <> cp - StubSize then exit;
For I := 1 to ResNameTbl^.numItems do
begin
NTR := ResNameTbl^.GetItem(I);
Inc(cp, succ(length(NTR^.Name^)) + sizeOf(SmallWord));
end;
Inc(cp);
if Header.lxEntTabOfs <> cp - StubSize then exit;
For I := 1 to EntryTbl^.numItems do
begin
EBR := EntryTbl^.GetItem(I);
Inc(cp, sizeOf(EBR^.Header.Count) + sizeOf(EBR^.Header.BndType));
if EBR^.DataSz <> 0
then Inc(cp, sizeOf(EBR^.Header.Obj) + EBR^.DataSz);
end;
Inc(cp, sizeOf(EBR^.Header.Count));
if ModDirTbl <> nil
then begin
if Header.lxDirTabOfs <> cp - StubSize then exit;
Inc(cp, Header.lxDirCnt * sizeOf(tResource));
end;
if PerPageCRC <> nil
then begin
if Header.lxPageSumOfs <> cp - StubSize then exit;
Inc(cp, Header.lxMpages * sizeOf(Longint));
end;
if Header.lxLdrSize <> cp - Header.lxObjTabOfs - StubSize then exit;
{ Write page fixup table }
L := cp;
if Header.lxFPageTabOfs <> cp - StubSize then exit;
Inc(cp, succ(Header.lxMpages) * sizeOf(Longint));
if Header.lxFRecTabOfs <> cp - StubSize then exit;
Inc(cp, FixRecTblSz);
if Header.lxImpModOfs <> cp - StubSize then exit;
For I := 1 to Header.lxImpModCnt do
if ImpModTbl^.GetItem(I) <> nil
then Inc(cp, succ(length(pString(ImpModTbl^.GetItem(I))^)))
else Inc(cp);
if Header.lxImpProcOfs <> cp - StubSize then exit;
For I := 1 to ImpProcTbl^.numItems do
if ImpProcTbl^.GetItem(I) <> nil
then Inc(cp, succ(length(pString(ImpProcTbl^.GetItem(I))^)))
else Inc(cp);
if Header.lxFixupSize <> cp - L then exit;
case SaveFlags and svfAlignFirstObj of
svfFOalnNone : ;
svfFOalnShift : cp := (cp + pred(1 shl ps)) and
($FFFFFFFF shl ps);
svfFOalnSector : cp := (cp + 511) and $FFFFFE00;
end;
if Header.lxDataPageOfs <> cp then exit;
f := 0;
For I := 1 to Header.lxMpages do
begin
K := PageOrder^[pred(I)];
with ObjMap^[K] do
begin
case PageFlags of
pgValid : begin
pL := @Header.lxDataPageOfs;
f := f or 1;
end;
pgIterData,
pgIterData2 : begin
if Header.lxIterMapOfs <> Header.lxDataPageOfs then exit;
pL := @Header.lxIterMapOfs;
case PageFlags of
pgIterData : f := f or 2;
pgIterData2 : f := f or 4;
end;
end;
pgInvalid,
pgZeroed : pL := nil;
else exit;
end;
if pL <> nil
then begin
if (Pages^[pred(K)] = nil) and (PageSize <> 0) then exit;
L := (cp - pL^ + pred(1 shl ps)) and
($FFFFFFFF shl ps);
cp := pL^ + L;
if PageDataOffset <> L shr ps then exit;
Inc(cp, PageSize);
end;
end;
end;
if (f = 1) and (packFlags and (pkfRunLength or pkfLempelZiv) <> 0) then exit;
if (f and 2 <> 0) and (packFlags and pkfRunLength = 0) then exit;
if (f and 4 <> 0) and (packFlags and pkfLempelZiv = 0) then exit;
if NResNameTbl^.numItems > 0
then begin
if Header.lxNResTabOfs <> cp then exit;
For I := 1 to NResNameTbl^.numItems do
begin
NTR := NResNameTbl^.GetItem(I);
Inc(cp, succ(length(NTR^.Name^)) + sizeOf(SmallWord));
end;
Inc(cp);
if Header.lxCbNResTabOfs <> cp - Header.lxNResTabOfs then exit;
end;
if (oldDbgOfs <> 0) or (Header.lxDebugInfoOfs <> 0)
then if (Header.lxDebugInfoOfs <> cp) or (Header.lxDebugInfoOfs <> oldDbgOfs)
then exit;
isPacked := _ON;
end;
destructor tLX.done;
begin
freeModule;
end;
end.